home *** CD-ROM | disk | FTP | other *** search
/ POINT Software Programming / PPROG1.ISO / pascal / swag / textwndw.swg / 0012_Text DrawLine Functions.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-11-21  |  8.0 KB  |  237 lines
  1. { WRITTEN BY TIM SCHEMPP
  2.   OCTOBER 21, 1993       }
  3.  
  4. unit drawline;
  5.  
  6. interface
  7.  
  8.    procedure horizline(x1,x2,y:integer; default:char);
  9.    procedure vertline(x,y1,y2:integer; default:char);
  10.    procedure rectlines(x1,y1,x2,y2:integer; default:char);
  11.  
  12. { IF writetomemory IS SET TO TRUE, LINES WILL BE DRAWN AN AVERAGE OF
  13.   ABOUT 15 TO 20 PERCENT FASTER THAN IF writetomemory IS SET TO FALSE.
  14.   HOWEVER, IF DATA IS WRITTEN DIRECTLY TO VIDEO MEMORY, YOU ARE STUCK WITH
  15.   THE SCREENS CURRENT COLORS (TEXTCOLOR AND TEXTBACKGROUND HAVE NO EFFECT).
  16.   THE DEFAULT VALUE OF writetomemory IS FALSE. }
  17.  
  18. var writetomemory:boolean;
  19.  
  20. implementation
  21.  uses crt; {for gotoxy, wherex and wherey}
  22.  
  23.      const symbols:array[1..40] of char=
  24.                       ('│','┤','╡','╢','╖','╕','╣','║','╗','╝','╜','╛','┐',
  25.                        '└','┴','┬','├','─','┼','╞','╟','╚','╔','╩','╦','╠',
  26.                        '═','╬','╧','╨','╤','╥','╙','╘','╒','╓','╫','╪','┘',
  27.                        '┌');
  28.  
  29.            codes:array[1..40] of string[4]=
  30.                     ('1010','1011','1012','2021','0021','0012','2022','2020',
  31.                      '0022','2002','2001','1002','0011','1100','1101','0111',
  32.                      '1110','0101','1111','1210','2120','2200','0220','2202',
  33.                      '0222','2220','0202','2222','1202','2101','0212','0121',
  34.                      '2100','1200','0210','0120','2121','1212','1001','0110');
  35.  
  36.             {THE SCREEN DIMENSIONS}
  37.             screenwidth=80;   screenlength=25;
  38.  
  39. {******}
  40.  
  41. {READS A CHARACTER FROM VIDEO MEMORY AT THE GIVEN COORDINANTS}
  42. function Memread(col,row:integer):char;
  43.  
  44.   Const
  45.     Seg = $B000; { Video memory address for color system  }
  46.     Ofs = $8000; { For monochrome system, make Ofs = $0000 }
  47.   Var
  48.     SChar : Integer;
  49.   Begin
  50.           SChar := ((Row-1)*160) + ((Col-1)*2); { Compute starting location }
  51.           memread:=chr(Mem[Seg:Ofs + SChar]);   { read character from memory}
  52.   End;
  53.  
  54. {******}
  55.  
  56. {WRITES A CHARACTER DIRECTORY TO VIDEO MEMORY AT THE GIVEN COORDINATES}
  57. {NOTE: THE CURRENT COLORS AT THE GIVEN COORDINANTS ARE USED FOR DRAWING.}
  58. procedure Memwrite(col,row:integer; c:char);
  59.  
  60.   Const
  61.     Seg = $B000; { Video memory address for color system  }
  62.     Ofs = $8000; { For monochrome system, make Ofs = $0000 }
  63.   Var
  64.     SChar : Integer;
  65.   Begin
  66.           SChar := ((Row-1)*160) + ((Col-1)*2); { Compute starting location }
  67.           Mem[Seg:Ofs + SChar]:=ord(c);         { write character to memory}
  68.   End;
  69.  
  70. {******}
  71.  
  72.    {PROCEDURE USED INTERNALLY TO CREATE A SET OF CHARACTER CODES}
  73.    function getcode(c:char; direction:byte):char;
  74.    var counter:integer;
  75.    begin
  76.     counter:=1;
  77.     while (counter<=40) and (c<>symbols[counter]) do inc(counter);
  78.     if counter>40 then getcode:='0' else getcode:=codes[counter,direction];
  79.    end;
  80.  
  81. {******}
  82.  
  83.    {PROCEDURE DRAWS A LINE IN TEXT MODE FROM (X1,Y) TO (X2,Y)}
  84.    {DEFAULT IS EITHER '1' OR '2' FOR SINGLE OF DOUBLE LINES}
  85.    procedure horizline(x1,x2,y:integer; default:char);
  86.  
  87.     var code:string[4];
  88.         defaultchar:char;
  89.         c,index:integer;
  90.         xpos,ypos:integer;
  91.  
  92.     begin
  93.      xpos:=wherex; ypos:=wherey;
  94.      if x2<x1 then begin c:=x1; x1:=x2; x2:=c; end;
  95.      if default='1' then defaultchar:=symbols[18]
  96.                     else defaultchar:=symbols[27];
  97.      for c:=x1 to x2 do
  98.       begin
  99.        code:='0000';
  100.        if y<>0 then code[1]:=getcode(memread(c,y-1),3) else code[1]:='0';
  101.        if (c=x2) and (x2=screenwidth) then code[2]:='0'
  102.           else if (c=x2) then code[2]:=getcode(memread(x2+1,y),4)
  103.                          else code[2]:=default;
  104.        if y<>screenlength then code[3]:=getcode(memread(c,y+1),1)
  105.                           else code[3]:='0';
  106.        if (c=x1) and (x1=1) then code[4]:='0'
  107.           else
  108.            if (c=x1) then code[4]:=getcode(memread(x1-1,y),2)
  109.                      else code[4]:=default;
  110.        index:=1;
  111.        while (index<=40) and (code<>codes[index]) do inc(index);
  112.        if writetomemory then
  113.          if index>40 then memwrite(c,y,defaultchar)
  114.                      else memwrite(c,y,symbols[index])
  115.                    else
  116.          if index>40 then begin gotoxy(c,y); write(defaultchar); end
  117.                      else begin gotoxy(c,y); write(symbols[index]); end;
  118.       end; {counter}
  119.       if not writetomemory then gotoxy(xpos,ypos);
  120.    end;
  121.  
  122. {******}
  123.  
  124.    {PROCEDURE DRAWS A LINE IN TEXT MODE FROM (X,Y1) TO (X,Y2)}
  125.    {DEFAULT IS EITHER '1' OR '2' FOR SINGLE OF DOUBLE LINES}
  126.    procedure vertline(x,y1,y2:integer; default:char);
  127.  
  128.     var code:string[4];
  129.         defaultchar:char;
  130.         c,index:integer;
  131.         xpos,ypos:integer;
  132.  
  133.     begin
  134.      xpos:=wherex; ypos:=wherey;
  135.      if y2<y1 then begin c:=y1; y1:=y2; y2:=c; end;
  136.      if default='1' then defaultchar:=symbols[1]
  137.                     else defaultchar:=symbols[8];
  138.      for c:=y1 to y2 do
  139.       begin
  140.        code:='0000';
  141.        if (c=y2) and (y2=screenlength) then code[3]:='0'
  142.           else if (c=y2) then code[3]:=getcode(memread(x,y2+1),1)
  143.                          else code[3]:=default;
  144.        if x<>screenwidth then code[2]:=getcode(memread(x+1,c),4)
  145.                          else code[1]:='0';
  146.        if x<>1 then code[4]:=getcode(memread(x-1,c),2)
  147.                else code[1]:='0';
  148.        if (c=y1) and (y1=0) then code[1]:='0'
  149.           else if (c=y1) then code[1]:=getcode(memread(x,y1-1),3)
  150.                          else code[1]:=default;
  151.        index:=1;
  152.        while (index<=40) and (code<>codes[index]) do inc(index);
  153.  
  154.        if writetomemory then
  155.              if index>40 then memwrite(x,c,defaultchar)
  156.                          else memwrite(x,c,symbols[index])
  157.                         else
  158.              if index>40 then begin gotoxy(x,c); write(defaultchar) end
  159.                          else begin gotoxy(x,c); write(symbols[index]); end;
  160.       end; {counter}
  161.      if not writetomemory then gotoxy(xpos,ypos);
  162.     end;
  163.  
  164. {******}
  165.  
  166.    {PROCEDURE DRAWS A RECTANGLE IN TEXT MODE}
  167.    {DEFAULT IS EITHER '1' OR '2' FOR SINGLE OF DOUBLE LINES}
  168.    procedure rectlines(x1,y1,x2,y2:integer; default:char);
  169.  
  170.    begin
  171.     horizline(x1,x2,y1,default);
  172.     horizline(x1,x2,y2,default);
  173.     vertline(x1,y1,y2,default);
  174.     vertline(x2,y1,y2,default);
  175.    end;
  176.  
  177. {******}
  178.  
  179.  begin
  180.   writetomemory:=false;
  181.  end. {unit}
  182.  
  183.  
  184.  {-------------------   DEMO PROGRAM ------------------------}
  185.  { ----------------      CUT HERE  --------------------------}
  186.  
  187.  { WRITTEN BY TIM SCHEMPP
  188.   OCTOBER 21, 1993       }
  189.  
  190.    {THIS PROGRAM DEMONSTARTES THE USE OF THE UNIT drawline.  UNIT DRAWLINE
  191.     WILL USE THE ASCII SET TO DRAW LINES.  WHEN LINE INTERSECTIONS ARE
  192.     FOUND, THE PROCEDURES DESCIDE WHICH CHARACTER FITS BEST.  THUS MAKING
  193.     IT VERY EASY TO CREATE VARIOUS TABLES AND OTHER SCREEN SET UPS.  THE
  194.     UNIT ALSO HAS THE ABILITY TO WRITE DIRECTORY TO VIDEO MEMORY FOR
  195.     A 15% TO 20% IMPROVEMENT IN SPEED.  SEE DRAWLINE.DOC FOR MORE INFO.}
  196.  
  197. program demo;
  198.  
  199.  uses crt,drawline;
  200.  
  201.  var counter:integer;
  202.  
  203.  begin
  204.   {SET THE SCREEN UP}
  205.   textbackground(black);
  206.   textcolor(white);
  207.   clrscr;
  208.  
  209.   {THE CALL TO CLEAR SCREEN FILLED THE SCREEN WITH SPACES WITH A BLACK
  210.    BACKGROUND AND A WHITE FOREGROUND.  IF writetomemory IS SET TO TRUE,
  211.    ALL OF THE OUTPUT WILL BE WRITTEN WITH A BLACK BACKGROUND AND A WHITE
  212.    FOREGROUND REGARDLESS OF TEXT ATTRIBUTE CHANGES.}
  213.  
  214.   {writetomemory:=true;} { <--- ADD THIS STATEMENT AND SEE COLOR DIFFERENCE}
  215.  
  216.   {WRITE SOME TEXT}
  217.    gotoxy(22,6);
  218.    textcolor(lightblue);
  219.    write('LINE DRAWING DEMONSTARTATION PROGRAM');
  220.    textcolor(yellow);
  221.   {DRAW A RECTANGLE WITH DOUBLE LINES}
  222.   rectlines(10,4,70,20,'2');
  223.   {DRAW SOME HORIZONTAL SINGLE LINES}
  224.   for counter:=9 to 19 do
  225.    horizline(10,70,counter,'1');
  226.   {DRAW SOME SINGLE VERTICLE LINES}
  227.    counter:=20;
  228.    while counter<=60 do
  229.     begin
  230.      vertline(counter,8,20,'1');
  231.      inc(counter,10);
  232.     end; {WHILE}
  233.   {DRAW ONE LAST HORIZONTAL DOUBLE LINE}
  234.    horizline(10,70,8,'2');
  235.  
  236.   repeat until keypressed;
  237.  end.